home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: Alpha / Whiteline Alpha.iso / tools / prtfolio / qchess.bas < prev    next >
Encoding:
BASIC Source File  |  1994-09-22  |  7.1 KB  |  158 lines
  1.  'QChess by Mike Weiblen [CIS: 72506,2072; Delphi: EKIM] 072485
  2.  DIM AZ(63), UZ(14), PZ(10): U = -8
  3. 40 CLS : PRINT "Portfolio QuikChess v1.0": PRINT : PRINT "Do you want to be white (Y/N) "; : GOSUB 7000
  4.  IF NOT ((IN = 89) OR (IN = 78)) THEN 40
  5.  FOR x = 0 TO 56 STEP 8: READ AZ(x): AZ(x + 7) = -AZ(x): AZ(x + 1) = 2: AZ(x + 6) = -2: NEXT x
  6.  FOR x = 1 TO 10: READ PZ(x): NEXT x
  7.  CLS : IF IN = 89 THEN AZ(24) = 9: AZ(32) = 99: AZ(31) = -9: AZ(39) = -99: I = 1: GOSUB 5000: GOTO 1500
  8.  AZ(24) = 99: AZ(32) = 9: AZ(31) = -99: AZ(39) = -9: I = -1: GOSUB 5000: GOTO 1000
  9. 500  U = U + 8: UZ(U) = S: UZ(U + 1) = x: UZ(U + 2) = y: UZ(U + 3) = A: UZ(U + 4) = B: UZ(U + 5) = Q0: UZ(U + 6) = AZ(A * 8 + B): AZ(A * 8 + B) = AZ(x * 8 + y): AZ(x * 8 + y) = 0: RETURN
  10. 600 S = UZ(U): x = UZ(U + 1): y = UZ(U + 2): A = UZ(U + 3): B = UZ(U + 4): Q0 = UZ(U + 5): AZ(x * 8 + y) = AZ(A * 8 + B): AZ(A * 8 + B) = UZ(U + 6): U = U - 8: RETURN
  11. 700 Z = 0: y = y + 1: IF y > 7 THEN y = 0: x = x + 1: Z = (x > 7)
  12.  RETURN
  13. 1000 'Computer Move
  14.  F = -9900: Q0 = 5: x = 0: y = 0
  15. 1040 PRINT@102,"Thinking "; CHR$(x + 65); CHR$(y + 49); : IF AZ(x * 8 + y) < 0 THEN GOSUB 2000
  16.  IF AZ(x * 8 + y) = 99 THEN X8 = x: Y8 = y
  17.  GOSUB 700: IF Z = 0 THEN 1040
  18. 1080 IF F < -900 THEN PRINT@102 "I Concede     "; : GOTO 9000
  19. 1090 AZ(A0 * 8 + B0) = AZ(X0 * 8 + Y0): AZ(X0 * 8 + Y0) = 0: IF AZ(A0 * 8 + B0) = -2 AND B0 = 0 THEN AZ(A0 * 8 + B0) = -9
  20. 1095 PRINT@102,"My move: "; CHR$(X0 + 65); CHR$(Y0 + 49); CHR$(A0 + 65); CHR$(B0 + 49); : x = X0: y = Y0: GOSUB 5500: x = A0: y = B0: GOSUB 5500
  21. 1100 V0 = 0: x = A0: y = B0: Q0 = 1: GOSUB 2000: IF V0 > 0 THEN PRINT@116,"Chk";
  22. 1500 'Player Move
  23. 1510 PRINT@182,"                 ";
  24.      PRINT@182,"Your move? ";
  25.     : GOSUB 7100
  26.  IF x = 80 THEN 1000: REM P - pass
  27.  IF x = 75 THEN 1710: REM k - castle right
  28.  IF x = 81 THEN 1730: REM q - castle left
  29.  x = x - 65: y = y - 49: A = A - 65: B = B - 49: P9 = 0
  30. 1522 IF x < 0 OR y < 0 OR A < 0 OR B < 0 OR x > 7 OR y > 7 OR A > 7 OR B > 7 THEN 1590
  31. 1525 IF AZ(x * 8 + y) < 1 THEN 1590
  32. 1527 IF AZ(x * 8 + y) = 2 AND AZ(A * 8 + B) = 0 AND y = 4 AND B = 5 AND ABS(x - A) = 1 THEN P9 = 1: GOTO 1530
  33. 1528 D = 0: A0 = A: B0 = B: Q0 = 3: GOSUB 2000: IF D = 0 THEN 1590
  34. 1530 A = A0: B = B0: AZ(A * 8 + B) = AZ(x * 8 + y): AZ(x * 8 + y) = 0: IF AZ(A * 8 + B) = 2 AND B = 7 THEN AZ(A * 8 + B) = 9
  35. 1540 GOSUB 5500: x = A: y = B: GOSUB 5500: IF P9 = 1 THEN y = B - 1: AZ(x * 8 + y) = 0: GOSUB 5500
  36. 1550 GOTO 1000
  37. 1590 BEEP: GOTO 1500
  38. 1700 'Castling
  39. 1710 IF AZ(32) = 99 AND AZ(56) = 7 THEN AZ(32) = 0: AZ(56) = 0: AZ(48) = 99: AZ(40) = 7: GOTO 1747
  40. 1720 IF AZ(24) = 99 AND AZ(0) = 7 THEN AZ(24) = 0: AZ(0) = 0: AZ(8) = 99: AZ(16) = 7: GOTO 1747
  41. 1725 GOTO 1590
  42. 1730 IF AZ(32) = 99 AND AZ(0) = 7 THEN AZ(32) = 0: AZ(0) = 0: AZ(16) = 99: AZ(24) = 7: GOTO 1747
  43. 1740 IF AZ(24) = 99 AND AZ(56) = 7 THEN AZ(24) = 0: AZ(56) = 0: AZ(40) = 99: AZ(32) = 7: GOTO 1747
  44. 1745 GOTO 1590
  45. 1747 GOSUB 5000: GOTO 1000
  46. 2000 'Scan Piece's Moves
  47. 2010 IF ABS(AZ(x * 8 + y)) = 99 THEN 2100
  48. 2020 ON ABS(AZ(x * 8 + y)) - 1 GOTO 2500, 9999, 2400, 2300, 9999, 2200, 9999, 2200
  49. 2100 'King
  50. 2110 A = x - 2
  51. 2120 B = y - 2: A = A + 1
  52. 2130 B = B + 1: GOSUB 3200: IF B < y + 1 THEN 2130
  53. 2132 IF A < x + 1 THEN 2120
  54. 2140 RETURN
  55. 2200 'Rook/Queen
  56. 2210 A = x: B = y
  57. 2220 A = A + 1: GOSUB 3200: IF S = 0 THEN 2220
  58. 2230 A = x
  59. 2240 A = A - 1: GOSUB 3200: IF S = 0 THEN 2240
  60. 2250 A = x
  61. 2260 B = B + 1: GOSUB 3200: IF S = 0 THEN 2260
  62. 2270 B = y
  63. 2280 B = B - 1: GOSUB 3200: IF S = 0 THEN 2280
  64. 2290 IF ABS(AZ(x * 8 + y)) = 7 THEN RETURN
  65. 2300 'Bishop/Queen
  66. 2310 A = x: B = y
  67. 2320 A = A + 1: B = B + 1: GOSUB 3200: IF S = 0 THEN 2320
  68. 2330 A = x: B = y
  69. 2340 A = A + 1: B = B - 1: GOSUB 3200: IF S = 0 THEN 2340
  70. 2350 A = x: B = y
  71. 2360 A = A - 1: B = B + 1: GOSUB 3200: IF S = 0 THEN 2360
  72. 2370 A = x: B = y
  73. 2380 A = A - 1: B = B - 1: GOSUB 3200: IF S = 0 THEN 2380
  74. 2390 RETURN
  75. 2400 'Knight
  76. 2410 A = x + 2: B = y + 1: GOSUB 3200: B = B - 2: GOSUB 3200: A = A - 4: GOSUB 3200: B = B + 2: GOSUB 3200
  77. 2420 A = A + 1: B = B + 1: GOSUB 3200: B = B - 4: GOSUB 3200: A = A + 2: GOSUB 3200: B = B + 4: GOTO 3200
  78. 2500 'Player Pawn
  79. 2510 A = x: IF AZ(x * 8 + y) < 0 THEN 2600
  80. 2520 B = y + 1: GOSUB 3000: IF y < 2 AND S = 0 THEN B = B + 1: GOSUB 3000
  81. 2530 B = y + 1: GOTO 2630
  82. 2600 'Computer Pawn
  83. 2610 B = y - 1: GOSUB 3000: IF y > 5 AND S = 0 THEN B = B - 1: GOSUB 3000
  84. 2620 B = y - 1
  85. 2630 A = x + 1: GOSUB 3100: A = A - 2: GOTO 3100
  86. 2640 'Move Range Check
  87. 3000 S = 0: IF AZ(A * 8 + B) THEN S = 1: RETURN
  88. 3020 GOTO 4000
  89. 3100 IF A < 0 OR A > 7 THEN RETURN
  90.  IF AZ(A * 8 + B) = 0 OR SGN(AZ(A * 8 + B)) = SGN(AZ(x * 8 + y)) THEN RETURN
  91.  GOTO 4000
  92. 3200 S = 0: IF A < 0 OR A > 7 OR B < 0 OR B > 7 THEN S = 1: RETURN
  93.  IF AZ(A * 8 + B) THEN S = 1
  94.  IF SGN(AZ(A * 8 + B)) = SGN(AZ(x * 8 + y)) THEN RETURN
  95. 4000 'Reason FOR  Scan
  96.  ON Q0 GOTO 4100, 4200, 4300, 4500, 4600
  97. 4100 'Player's King Threatened?
  98.  IF AZ(A * 8 + B) = 99 THEN V0 = V0 + 1
  99.  RETURN
  100. 4200 'Comp Piece Protected?
  101.  IF UZ(U + 3) = A AND UZ(U + 4) = B THEN P = 0
  102.  RETURN
  103. 4300 'Player Move Valid?
  104.  IF A0 = A AND B0 = B THEN D = 1
  105.  RETURN
  106. 4500 'Comp Piece Threatened?
  107.  IF AZ(A * 8 + B) > -1 THEN RETURN
  108.  P = AZ(A * 8 + B): IF ABS(P) > AZ(x * 8 + y) THEN 4580
  109.  GOSUB 500: Q0 = 2: x = 0: y = 0
  110. 4550 IF AZ(x * 8 + y) < 0 THEN GOSUB 2000: IF P = 0 THEN 4570
  111.  GOSUB 700: IF Z = 0 THEN 4550
  112. 4570 GOSUB 600
  113. 4580 IF P < V0 THEN V0 = P
  114.  RETURN
  115. 4600 'Find Best Comp Move
  116.  IF AZ(A * 8 + B) = 99 THEN PRINT@102, "CheckMate     "; : GOTO 9000
  117.  GOSUB 500: V0 = 0: Q0 = 4: x = 0: y = 0
  118. 4630 IF AZ(x * 8 + y) > 0 THEN GOSUB 2000
  119.  GOSUB 700: IF Z = 0 THEN 4630
  120.  x = UZ(U + 3): y = UZ(U + 4): Q0 = 1: GOSUB 2000: GOSUB 600
  121.  F9 = RND * 10: F8 = ABS(A * 10 - 35) + ABS(B * 10 - 35): F7 = 0: IF AZ(x * 8 + y) > -10 AND AZ(x * 8 + y) < -1 THEN F7 = 10 - ABS(X8 - A) - ABS(Y8 - B)
  122.  F9 = F9 + (100 - F8) + F7 + AZ(A * 8 + B) * 100 + V0 * 100: IF F9 > F THEN F = F9: X0 = x: Y0 = y: A0 = A: B0 = B
  123.  RETURN
  124. 5000 FOR y = 7 TO 0 STEP -1: LOCATE (8 - y), y + 1: FOR x = 0 TO 7: GOSUB 5500: NEXT x:next y: RETURN
  125. 5500 'Display piece
  126. 5520 LOCATE (8 - y), x * 2 + 4: g6 = AZ(x * 8 + y): IF g6 * I > 0 THEN PRINT ""; : REM CHR$(27); "p";
  127.  IF g6 = 0 THEN g6 = 3: IF (x + y) % 2 = 0 THEN g6 = 1
  128.  IF g6 = 99 THEN g6 = 10 ELSE IF g6 = -99 THEN g6 = -10
  129.  
  130.  
  131.    IF (x + y) % 2 = 0 THEN bj$ = CHR$(219) ELSE bj$ = " "
  132.    IF g6 > 0 THEN PRINT CHR$(PZ(ABS(g6))); bj$;: RETURN: REM  CHR$(27); "q"; : RETURN
  133.    PRINT CHR$(32 + PZ(ABS(g6))); bj$;: RETURN
  134.  
  135. 7000 PRINT " "; :
  136.     LOCATE (CSRLIN), (POS(0) - 1): REM CHR$(8);
  137. 7010 IN = 0: IN$ = INKEY$: IF IN$ <> "" THEN IN = ASC(IN$)
  138.  IF IN = 0 THEN 7010
  139.  IF IN = 27 THEN 9010
  140.  IF IN > 90 THEN IN = IN - 32
  141.  
  142.  
  143.   IF IN = 8 THEN LOCATE CSRLIN, POS(0) - 1: RETURN
  144.   PRINT CHR$(IN); : RETURN
  145.  
  146. 7100 GOSUB 7000: IF IN = 8 THEN PRINT " "; : GOTO 7100
  147. 7105 x = IN: IF x = 80 OR x = 75 OR x = 81 THEN RETURN
  148. 7110 GOSUB 7000: IF IN = 8 THEN 7100
  149. 7120 y = IN: GOSUB 7000: IF IN = 8 THEN 7110
  150.  A = IN: GOSUB 7000: IF IN = 8 THEN 7120
  151.  B = IN: RETURN
  152. 9000 BEEP:PRINT@262,"Hit any key"; : GOSUB 7000
  153. 9010 LOCATE 8, 39: if isrun then run "menu" else END
  154. 9100 DATA 7,4,5,0,0,5,4,7
  155. 9200 DATA 219,80,32,78,66,32,82,32,81,75
  156.  
  157. 9999 Print "Internal Error":end
  158. ə